/* Definitions for custom, native types.

   This file is part of khipu.

   khipu is free software: you can redistribute it and/or modify
   it under the terms of the GNU Lesser General Public License as published by
   the Free Software Foundation; either version 3 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU Lesser General Public License for more details.

   You should have received a copy of the GNU Lesser General Public License
   along with this program.  If not, see <https://www.gnu.org/licenses/>.  */

#include <new>
#include "custom.hpp"
#include "memory.hpp"
#include "str.hpp"
#include "symbol.hpp"
#include "types.hpp"
#include "thread.hpp"

KP_DECLS_BEGIN

custom_base* custom_base::alloc_raw (size_t size)
{
  /* We cannot use 'alloch', because it allocates and initializes a varobj,
   * disregarding any adjustments that must be made by a class with virtual
   * methods. So we inline the needed part here. */
  auto ret = (custom_base *)ensure_mask_impl (xmalloc (size), TYPE_SHIFT);
  ret->vo_size = (uint32_t)size;
  return (ret);
}

static void
check_custom_type (interpreter *interp, object *tp,
                   object name, custom_base *bp)
{
  if (!tp)
    interp->raise ("arg-error", "type descriptor must not be null");

  object ty = *tp;
  valref_head h (interp);
  fast_valref parents (interp, NIL), slots (interp, NIL);

  if (ty != 0)
    {
    check:
      if (type_name (ty) != name)
        interp->raise ("arg-error", "different names used for "
                                    "the same custom type");

      return;
    }

  bp->fill_type (interp, *parents, *slots);
  if (singlethr_p ())
    *tp = type (interp, name, *parents, *slots);
  else if (!atomic_cas_bool ((atomic_t *)tp, ty,
                             type (interp, name, *parents, *slots)))
    goto check;
}

custom_base* custom_base::xalloc (interpreter *interp, object *tp,
                                  const char *name, custom_base *bp)
{
  return (custom_base::xalloc (interp, tp, intern (interp, name), bp));
}

custom_base* custom_base::xalloc (interpreter *interp, object *tp,
                                  const char *name, uint32_t len,
                                  custom_base *bp)
{
  return (custom_base::xalloc (interp, tp, intern (interp, name, len), bp));
}

custom_base* custom_base::xalloc (interpreter *interp, object *tp,
                                  object name, custom_base *ret)
{
  if (str_p (name))
    name = intern (interp, as_str (name));
  else if (!symbol_p (name))
    interp->raise ("arg-error", "type name must be a string or symbol");

  try
    {
      new (ret) custom_base ();
      check_custom_type (interp, tp, name, ret);
    }
  catch (...)
    {
      destroy (ret);
      xfree (ret);
      throw;
    }

  ret->vo_full = 0;
  ret->vo_type = typecode::CUSTOM;
  ret->fini = nullptr;
  ret->type_ptr = tp;
  interp->alval = ret->as_obj ();
  gc_register (interp, ret, ret->vo_size);
  return (ret);
}

KP_DECLS_END
